CLEAR, 40960 DEFINT a-z OPTION BASE 1 DIM deck(52),upcp(7,12),downcp(7,6),cpndx(7,2),ap(4,12) 'card pile arrays DIM suit(21,4), cardval(21,13), card(99,52) 'card graphics arrays DIM topdeck(2), temp(2,2), drawdeck(24), playdeck(24) GOTO Begin 'MigaSol version 1.0 'Copyright 1986, Jon Scarpelli. All rights reserved. 'The author retains all rights to this software and 'hereby grants license for the free dissemination 'of this software product for non-commercial use only 'under the sole condition that this notice not be 'removed. The author reserves the right to revoke this 'license at any time. 'Now that that's done, this software is distributed as 'Shareware. If you find yourself using this software 'and would like to encourage both the Shareware concept 'and further development of this program, please send 'a contribution ($10 would be nice) to the author: ' Jon Scarpelli ' 3209 Lindenwood ' Dearborn, MI 48120 'Planned enhancements include music, rules to reduce but 'not eliminate cheating, score keeping, and an UNDO 'function. Your comments and suggestions will be 'appreciated. ENJOY THIS! Begin: GOSUB GetGraphics GOSUB StartGame LOCATE 16,3:PRINT "HELP" LOCATE 18,3:PRINT "PLAY " HelpOrPlay: WHILE MOUSE(0)<>1:WEND x=MOUSE(3):y=MOUSE(4) IF x>16 AND x<48 AND y>120 AND y<129 THEN HelpNeeded=-1 END IF IF HelpNeeded THEN GOSUB PlayInstructions GOTO CheckMouse ELSE LOCATE 16,3:PRINT "Have at it! " LOCATE 18,3:PRINT "REDEAL" GOTO CheckMouse END IF CheckMouse: WHILE MOUSE(0)<>1:WEND x=MOUSE(3):y=MOUSE(4) ProcessSelection: LOCATE 2,3 PRINT "Wait..." LOCATE 3,3 PRINT " " LOCATE 16,3 PRINT " " IF x>16 AND x<56 AND y>152 AND y<161 THEN IF click=frompos THEN Oops=-1:click=newpos GOTO ShowSelect ELSE LOCATE 16,3:PRINT "Too late... " END IF ELSEIF x>16 AND x<64 AND y>136 AND y<145 THEN redeal=-1 GOSUB StartGame GOTO CheckMouse ELSE click=click*-1 END IF IF click=frompos THEN fromcardpile=0:fromplaypile=0 tocardpile=0:newpile=0 END IF GOSUB TestPile IF UsingCardpile THEN IF cpndx(pile,up)>0 THEN 'up card available GOSUB TestUpCard 'was card picked available & get y positions IF validcard THEN IF click=frompos THEN fromx1=x1:fromy1=y1 fromx2=x2:fromy2=y2 fromcard=card:frompile=pile fromupndx=cpndx(pile,up) fromdownndx=cpndx(pile,down) cardstomove=fromupndx-card+1 fromcardpile=-1 ELSE 'click=newpos tocardpile=-1 newx1=x1:newy1=y1 newx2=x2:newy2=y2 newcard=card:newpile=pile newupndx=cpndx(newpile,up) IF fromcardpile THEN GOSUB UpdateArrays IF OkToMove THEN GOSUB MoveCard END IF ELSE GOSUB UsePlayPile END IF END IF ELSE click=click*-1 END IF ELSEIF cpndx(pile,down)>0 THEN 'down card available GOSUB TestDownCard IF validcard THEN IF click=frompos THEN 'turn card over CurrentCard=downcp(pile,1) PUT (x1,y1),card(1,CurrentCard),PSET IF cpndx(pile,down)>1 THEN FOR i=1 TO 5 downcp(pile,i)=downcp(pile,i+1) NEXT i END IF cpndx(pile,up)=1 cpndx(pile,down)=cpndx(pile,down)-1 cpndx(pile,up)=1 upcp(pile,1)=CurrentCard click=click*-1 END IF ELSE click=click*-1 END IF ELSE 'empty pile IF click=newpos THEN newcard=1:newpile=pile newy1=5:newx1=x1:newupndx=0 IF fromcardpile THEN GOSUB UpdateArrays IF OkToMove THEN GOSUB MoveCard END IF ELSE tocardpile=-1 GOSUB UsePlayPile END IF ELSE LOCATE 16,3 PRINT "Not today... " click=click*-1 END IF END IF ELSEIF ace1pile OR ace2pile OR ace3pile OR ace4pile THEN IF click=newpos THEN newx1=580:newcard=1 IF ace1pile THEN newpile=1:newy1=35 ELSEIF ace2pile THEN newpile=2:newy1=70 ELSEIF ace3pile THEN newpile=3:newy1=105 ELSE newpile=4:newy1=140 END IF GOSUB UpdateAceArray IF OkToMove THEN IF fromplaypile THEN GOSUB UsePlayPile ELSE GOSUB MoveCard END IF END IF END IF ELSEIF UsingDrawpile THEN GOSUB UseDrawPile click=newpos ELSEIF UsingPlaypile AND cardtoplay>0 THEN GOSUB UsePlayPile ELSE click=click*-1 END IF ShowSelect: Oops=0 LOCATE 2,3 PRINT "Select " LOCATE 3,3 IF click=frompos THEN PRINT "To... " ELSE PRINT "From..." END IF GOTO CheckMouse TestPile: UsingCardpile=0:pile=0 UsingDrawpile=0:UsingPlaypile=0 ace1pile=0:ace2pile=0 ace3pile=0:ace4pile=0 IF y>4 AND y<161 AND x>131 AND x<549 THEN IF x>131 AND x<164 THEN pile=1:UsingCardpile=-1 x1=132:x2=163 ELSEIF x>195 AND x<228 THEN pile=2:UsingCardpile=-1 x1=196:x2=227 ELSEIF x>259 AND x< 292 THEN pile=3:UsingCardpile=-1 x1=260:x2=291 ELSEIF x>323 AND x<356 THEN pile=4:UsingCardpile=-1 x1=324:x2=355 ELSEIF x>387 AND x<420 THEN pile=5:UsingCardpile=-1 x1=388:x2=419 ELSEIF x>451 AND x< 484 THEN pile=6:UsingCardpile=-1 x1=452:x2=483 ELSEIF x>515 AND x<548 THEN pile=7:UsingCardpile=-1 x1=516:x2=547 ELSE LOCATE 16,3 PRINT "Which pile? " END IF ELSEIF x>19 AND x<52 AND y>39 AND y<64 THEN UsingPlaypile=-1 x1=20:y1=40:x2=51:y2=63 ELSEIF x>19 AND x<52 AND y>79 AND y<104 THEN UsingDrawpile=-1 ELSEIF x>579 AND x<612 AND click=newpos THEN x1=580:x2=611 IF y>34 AND y<59 THEN ace1pile=-1 '1st ace pile y1=35:y2=58 ELSEIF y>69 AND y<94 THEN ace2pile=-1 '2nd ace pile, etc. y1=70:y2=93 ELSEIF y>104 AND y<129 THEN ace3pile=-1 y1=105:y2=128 ELSEIF y>139 AND y<164 THEN ace4pile=-1 y1=140:y2=163 ELSE LOCATE 16,3 PRINT "How's that? " END IF ELSE LOCATE 16,3 PRINT "Whuh..?? " END IF RETURN TestUpCard: card=0:validcard=0 IF y>4 AND y<161 THEN card=INT((y-5)/12)+1 IF card<=cpndx(pile,up) THEN 'pointing to top half validcard=-1 'of any up card ELSEIF card-1=cpndx(pile,up) THEN 'pointing to bottom card=card-1 'half of last up card validcard=-1 ELSE LOCATE 16,3:PRINT "Which card? " END IF 'Get y1 and y2 position IF validcard THEN 'card <= cpndx y1=5+(card-1)*12 y2=5+(cpndx(pile,up)+1)*12 END IF RETURN TestDownCard: card=0:validcard=0 IF y>4 AND y<161 THEN card=INT((y-5)/12)+1 IF card=1 OR card=2 THEN card=1 y1=5 validcard=-1 ELSE LOCATE 16,3:PRINT "Come again? " END IF RETURN UpdateArrays: OkToMove=0 IF frompile<>newpile THEN GOSUB FromPileRedraw j=1 IF newupndx>0 THEN 'cards already showing newy1=newy1+12 'offset so as not to cover END IF FOR i=fromcard TO fromcard+cardstomove-1 upcp(newpile,newupndx+j)=upcp(frompile,i) upcp(frompile,i)=0 j=j+1 NEXT i cpndx(frompile,up)=fromupndx-cardstomove cpndx(newpile,up)=newupndx+cardstomove OkToMove=-1 ELSE LOCATE 16,3 PRINT "Nope... " END IF RETURN UpdateAceArray: OkToMove=0 IF fromcardpile THEN CurrentCard=upcp(frompile,fromcard) ELSE CurrentCard=playdeck(cardtoplay) END IF IF ap(newpile,1)>0 THEN 'not 1st card on pile IF CurrentCard=ap(newpile,1)+1 THEN 'consequtive cards IF fromcardpile THEN GOSUB FromPileRedraw upcp(frompile,fromcard)=0 cpndx(frompile,up)=fromupndx-1 END IF newx1=580:newcard=1 FOR i=1 TO 11 ap(newpile,i+1)=ap(newpile,i) NEXT i ap(newpile,1)=CurrentCard OkToMove=-1 ELSE LOCATE 16,3 PRINT "Can't do that" END IF ELSEIF CurrentCard=1 OR CurrentCard=14 OR CurrentCard=27 OR CurrentCard=40 THEN IF fromcardpile THEN GOSUB FromPileRedraw upcp(frompile,fromcard)=0 cpndx(frompile,up)=fromupndx-1 END IF newx1=580:newcard=1 ap(newpile,1)=CurrentCard OkToMove=-1 ELSE LOCATE 16,3 PRINT "Can't do that" END IF RETURN FromPileRedraw: DrawEmptyPile=0:DrawCardBack=0 IF fromcard=1 THEN '1st card moving IF fromdownndx>0 THEN 'down cards available DrawCardBack=-1 ELSE DrawEmptyPile=-1 END IF ELSE CardToRedraw=upcp(frompile,fromcard-1) END IF RETURN MoveCard: ERASE temp arraysize=3+INT((16+fromx2-fromx1)/16)*(1+fromy2-fromy1)*2 DIM temp(arraysize,2) GET (fromx1,fromy1)-(fromx2,fromy2),temp(1,1) ' cards GET (fromx1-32,fromy1)-(fromx2-32,fromy2),temp(1,2) 'clear background PUT (fromx1,fromy1),temp(1,2),PSET 'clear fromcards 'put bottom half of card left or empty pile or back of down card IF DrawEmptyPile THEN LINE (fromx1,fromy1)-(fromx1+31,fromy1+23),1,b DrawEmptyPile=0 ELSEIF DrawCardBack THEN PATTERN ,topdeck COLOR 3,2 LINE (fromx1,fromy1)-(fromx1+31,fromy1+23),,bf DrawCardBack=0 ELSE PUT (fromx1,fromy1-12),card(1,CardToRedraw),PSET END IF PUT (newx1,newy1),temp(1,1),PSET RETURN UseDrawPile: IF click = frompos THEN IF cardsdealt < cardstodeal THEN IF cardsdealt < cardstodeal-2 THEN FOR i=1 TO 3 playdeck(cardtoplay+i)=drawdeck(cardsdealt+i) NEXT i cardtoplay=cardtoplay+3 cardsdealt=cardsdealt+3 ELSEIF cardsdealt=cardstodeal-2 THEN playdeck(cardtoplay+1)=drawdeck(cardsdealt+1) playdeck(cardtoplay+2)=drawdeck(cardsdealt+2) cardtoplay=cardtoplay+2 cardsdealt=cardsdealt+2 ELSEIF cardsdealt=cardstodeal-1 THEN playdeck(cardtoplay+1)=drawdeck(cardsdealt+1) cardtoplay=cardtoplay+1 cardsdealt=cardsdealt+1 END IF newx1=20:newy1=40 'playpile coords CurrentCard=playdeck(cardtoplay) 'get current card to play PUT (newx1,newy1),card(1,CurrentCard),PSET 'show current card IF cardsdealt = cardstodeal THEN 'draw empty draw pile ERASE temp DIM temp(99,2) GET (60,162)-(91,185),temp(1,2) 'get empty background PUT (20,80),temp(1,2),PSET 'clear draw deck LINE (20,80)-(51,103),1,b 'draw empty pile END IF ELSE 'empty draw pile FOR i=1 TO cardstodeal-cardsplayed 'move play pile to draw pile drawdeck(i) = playdeck(i) NEXT i cardstodeal = cardstodeal-cardsplayed cardsplayed=0:cardtoplay=0:cardsdealt=0 IF cardstodeal>0 THEN ERASE temp DIM temp( 99,2) GET (60,162)-(91,185),temp(1,2) 'get empty background PUT (20,40),temp(1,2),PSET 'clear play deck LINE (20,40)-(51,63),1,b 'draw empty pile PATTERN ,topdeck COLOR 3,2 LINE (20,80)-(51,103),,bf END IF END IF END IF RETURN UsePlayPile: IF cardtoplay > 0 THEN IF click = frompos THEN fromx1=x1:fromx2=x2 fromy1=y1:fromy2=y2 validcard=-1:fromplaypile=-1 fromcardpile=0 ELSE 'click=newpos CurrentCard=playdeck(cardtoplay) cardsplayed=cardsplayed+1 cardtoplay=cardtoplay-1 IF cardtoplay=0 THEN DrawEmptyPile=-1 ELSE CardToRedraw=playdeck(cardtoplay) END IF IF tocardpile THEN IF newupndx > 0 THEN newy1=newy1+12 END IF upcp(newpile,newupndx+1)=CurrentCard cpndx(newpile,up)=newupndx+1 END IF ERASE temp DIM temp(99,2) GET (fromx1,fromy1)-(fromx2,fromy2),temp(1,1) PUT (newx1,newy1),temp(1,1),PSET IF NOT DrawEmptyPile THEN PUT (fromx1,fromy1),card(1,CardToRedraw),PSET ELSE GET (60,162)-(91,185),temp(1,2) 'get empty background PUT (fromx1,fromy1),temp(1,2),PSET 'clear play deck LINE (fromx1,fromy1)-(fromx2,fromy2),1,b DrawEmptyPile=0 END IF OkToMove=-1 END IF END IF RETURN StartGame: up=1:down=2 frompos=-1:newpos=1:click=newpos:redeal=0 cardstodeal=24:cardsdealt=0:cardtoplay=0 cardsplayed=0 COLOR 1,0 InitArrays: FOR card=1 TO 52 deck(card)=card NEXT card FOR pile=1 TO 7 cpndx(pile,up)=1 cpndx(pile,down)=pile-1 NEXT pile FOR pile=1 TO 4 FOR card=1 TO 12 ap(pile,card)=0 NEXT card NEXT pile FOR card=1 TO 24 playdeck(card)=0 drawdeck(card)=0 NEXT card FOR pile=1 TO 7 FOR card=1 TO 12 upcp(pile,card)=0 NEXT card NEXT pile FOR pile=1 TO 7 FOR card=1 TO 6 downcp(pile,card)=0 NEXT card NEXT pile RANDOMIZE TIMER played=1 Gencards: FOR i=1 TO 52 x=INT(RND*52+1) SWAP deck(i),deck(x) NEXT i DealCards: played=0 FOR card=1 TO 7 FOR pile = card TO 7 played=played+1 IF card=1 THEN upcp(pile,card)=deck(played) ELSE downcp(pile,card-1)=deck(played) END IF NEXT pile NEXT card BuildDrawDeck: FOR i=29 TO 52 j=i-28 drawdeck(j)=deck(i) NEXT i TurnPiles: CLS COLOR 1,0 FOR pile=1 TO 7 ' card piles CurrentCard=upcp(pile,1) x=132+((pile-1)*64) y=5 PUT (x,y),card(1,CurrentCard),PSET NEXT pile FOR pile=1 TO 4 ' empty ace piles x=580 y=35*pile LINE (x,y)-(x+31,y+23),1,b NEXT pile ' create empty play pile and draw pile x=20 y=40 LINE (x,y)-(x+31,y+23),1,b x=20 y=80 PATTERN ,topdeck COLOR 3,2 LINE (x,y)-(x+31,y+23),,bf x=1:y=1 LOCATE 18,3 PRINT "REDEAL" LOCATE 20,3 PRINT "Oops!" LOCATE 2,3 PRINT "Select " LOCATE 3,3 PRINT "From..." RETURN GetGraphics: 'load 1st 3 words of each array FOR i=1 TO 4 suit (1,i)=16 suit (2,i)=9 suit (3,i)=2 NEXT i FOR i=1 TO 13 cardval (1,i)=16 cardval (2,i)=9 cardval (3,i)=2 NEXT i FOR i=1 TO 52 card (1,i)=32 card (2,i)=24 card (3,i)=2 NEXT i FOR j=1 TO 4 FOR i=4 TO 12 READ suit(i,j) NEXT i NEXT j FOR j=13 TO 1 STEP -1 FOR i=4 TO 12 READ cardval(i,j) NEXT i NEXT j READ topdeck(1):READ topdeck(2) k=1 PRINT "Please wait while I print a new deck for you..." FOR i=1 TO 4 FOR j=1 TO 13 LINE (16,59)-(47,82),1,bf PUT (16,60),cardval(1,j) PUT (32,60),suit(1,i) IF i=1 OR i=3 THEN suitcolor=2 :ELSE suitcolor=3 PAINT (40,64),suitcolor,1 IF j <> 10 AND j <> 13 THEN PAINT (24,60),suitcolor,1 IF j=10 THEN PAINT (24,60),suitcolor,1: PAINT (18,60),suitcolor,1 IF j=13 THEN PAINT (20,60),suitcolor,1 GET (16,59)-(47,82),card(1,k) k=k+1 NEXT j NEXT i RETURN PlayInstructions: LOCATE 5,38:PRINT "CARD PILES" LOCATE 6,9:PRINT "PLAY" LOCATE 6,67:PRINT "ACES" LOCATE 11,9:PRINT "DRAW" LOCATE 16,3:PRINT " " LOCATE 18,3:PRINT "PLAY" COLOR 1,0 LOCATE 7,15 PRINT "1 Cards are moved (3 at a time) from the draw pile" LOCATE 8,15 PRINT " to the play pile by clicking once on the draw pile." LOCATE 9,15 PRINT "2 A checkered design indicates that a card is face" LOCATE 10,15 PRINT " down on the pile, ready for play. Down cards are" LOCATE 11,15 PRINT " turned up by clicking once on the down card." LOCATE 12,15 PRINT "3 Cards are moved from the play pile and card piles to" LOCATE 13,15 PRINT " the card piles and ace piles by clicking once on the" LOCATE 14,15 PRINT " card to be moved (Select From) and then clicking once" LOCATE 15,15 PRINT " on the card position to move to (Select To)." LOCATE 16,15 PRINT "4 One-click the empty draw pile to recycle the play pile." LOCATE 17,15 PRINT "5 Watch the Select box. It tells you what action is " LOCATE 18,15 PRINT " expected. If you click on a card and see no response in" LOCATE 19,15 PRINT " the Select box, wait one full second, then click on the" LOCATE 20,15 PRINT " card indicated in the Select box." LOCATE 21,15 PRINT "6 Oops! will change Select To... to Select From..." LOCATE 22,15 PRINT "7 This game will allow you to cheat and win. Good luck." COLOR 3,2 HelpNeeded=0:redeal=-1 RETURN 'club data DATA &h0180,&h07e0,&h07e0,&h03c0 DATA &h1ff8,&h3ffc,&h3ffc,&h1db8,&h0180 'heart data DATA &h0e38,&h1f7c,&h1ffc,&h1ffc DATA &h1ffc,&h0ff8,&h07f0,&h01c0,&h0080 'spade data DATA &h0180,&h03c0,&h07e0,&h0ff0 DATA &h1ff8,&h1ff8,&h1db8,&h0180,&h0180 'diamond data DATA &h0380,&h07c0,&h0fe0,&h3ff8 DATA &h7ffc,&h3ff8,&h0fe0,&h07c0,&h0380 'king data DATA &h1c38,&h0c30,&h0c60,&h0ce0 DATA &h0fc0,&h0c60,&h0c70,&h0c30,&h1c38 'queen data DATA &h07c0,&h1c70,&h3838,&h3838 DATA &h3838,&h39b8,&h39b8,&h1cfc,&h07ce 'jack data DATA &h07f8,&h00e0,&h00e0,&h00e0 DATA &h00e0,&h00e0,&h38e0,&h38e0,&h1fc0 '10 data DATA &h31fc,&h738e,&h7306,&h3306 DATA &h3306,&h3306,&h3306,&h338e,&h79fc '9 data DATA &h07f0,&h0e38,&h0e38,&h0e38 DATA &h07f8,&h0038,&h0e38,&h0770,&h03e0 '8 data DATA &h07f0,&h1e3c,&h1c1c,&h1e3c DATA &h07f0,&h1e3c,&h1c1c,&h1e3c,&h07f0 '7 data DATA &h1ffc,&h1c1c,&h0038,&h0070 DATA &h00e0,&h01c0,&h0380,&h0380,&h0380 '6 data DATA &h07e0,&h0e00,&h1c00,&h1c00 DATA &h1ff0,&h1c38,&h1c38,&h0e38,&h07f0 '5 data DATA &h1ff0,&h1c00,&h1c00,&h1ff0 DATA &h0038,&h001c,&h1c1c,&h0e38,&h07f0 '4 data DATA &h00f8,&h01f8,&h03b8,&h0738 DATA &h0e38,&h1c38,&h1ffc,&h0038,&h0038 '3 data DATA &h1ffc,&h001c,&h0038,&h03f0 DATA &h0038,&h001c,&h301c,&h1838,&h0ff0 '2 data DATA &h0ff8,&h1e1c,&h1c1c,&h003c DATA &h07f8,&h1f00,&h1c00,&h1c00,&h1ff8 'ace data DATA &h01c0,&h03e0,&h0770,&h0e38 DATA &h1c1c,&h1ffc,&h1c1c,&h1c1c,&h1c1c 'topdeck data DATA &hf0f0,&h0f0f